home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Libris Britannia 4
/
science library(b).zip
/
science library(b)
/
UTILITIE
/
CPU_MEMO
/
1648.ZIP
/
TESS-P.ARC
/
TSDAYTIM.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1988-10-02
|
18KB
|
512 lines
{****************************************************************************
* TSDAYTIM.PAS -- Turbo Pascal 4.0 demonstration program
***************************************************************************
SUBTTL TesSeRact Revision Level 1
;--------------------------------------------------------------------------
; TesSeRact(tm) -- A Library of Routines for Creating Ram-Resident (TSR)
; programs for the IBM PC and compatible Personal
; Computers.
;
;The software, documentation and source code are:
;
; Copyright (C) 1986, 1987, 1988 Tesseract Development Team
; All Rights Reserved
;
; c/o Chip Rabinowitz
; Innovative Data Concepts
; 2084 Woodlawn Avenue
; Glenside, PA 19038
; 1-215-884-3373
;
;--------------------------------------------------------------------------
; This product supports the TesSeRact Standard for Ram-Resident Program
; Communication. For information about TesSeRact, contact the TesSeRact
; Development Team at:
; Compuserve: 70731,20
; MCIMAIL: 315-5415
; This MCIMAIL Account has been provided to the TesSeRact Development
; Team by Borland International, Inc. The TesSeRact Development Team
; is in no way associated with Borland International, Inc.
;--------------------------------------------------------------------------}
PROGRAM TSDayTim; { Copyright 1988 TesSeRact Development Team }
{$R-,S-,I-,D+,T+,F-,V-,B-,N-,L+ }
{$M 1024,0,0 } { this line needed to reduce stack and heap! }
Uses DOS, CRT, TESSTP; { program redone 02-24-88, Jim Kyle, for RDT }
{*************************************************************************
* This program is a VERY simple-minded TSR that merely displays the *
* time and date in the top RH corner, and which can also pop up and *
* remove itself from memory. All of the fancy frills (snow-free write *
* to CGA screens, full compatibility with EGA/VGA modes, file I/O, and *
* the like) have been left out, to concentrate on those actions which *
* are REQUIRED to interface TesSeRact with Turbo Pascal 4 programs. *
*************************************************************************}
{ first we declare constants and such....... }
CONST
MAXVIDSIZE = 2000 ; { TP4 version only uses 80x25 }
MONONORM = $07 ;
MONOREV = $70 ;
VAR
savescreen : array [1..MAXVIDSIZE] of word ;
{ buffer to save screen image }
NormAtt, { Default Normal Attribute }
RevAtt, { Default Reverse Attribute }
curmode, { Current video mode }
oldcur, { Old Cursor shape }
oldpos : word; { Old Cursor position }
biosvid : pointer; { Pointer to video buffer }
BackStack : array [0..1023] of char; { Stack area for BackGround }
buffer : array [0..17] of byte ; { work buffer for date/time format}
BackFlag : word; { Background flag to signal }
{ additional processing }
idnum, { TSR Identification Number }
hours, { Current hour of day }
mins, { Current minute of hour }
secs, { Current seconds of minute }
yr, { for date report }
mon,
day,
ticks : word; { Timer-tick counter }
regs : registers; { workspace for INTR interfaces }
{***********************************************************
* Video Support Routines *
*********************************************************CR}
PROCEDURE c_str( row : integer; str : string );
{ Print a string, centered }
VAR
wid : integer; { temporary width variable }
BEGIN
wid := (80 - length(str)) SHR 1; { calculate cursor position }
gotoxy(wid, row); { go there }
write(str); { display the string }
END;
PROCEDURE getscrn; { very primitive screen saver }
BEGIN { WILL snow with CGA... }
move( biosvid^, savescreen, sizeof(savescreen) );
END;
PROCEDURE putscrn; { very primitive screen restore }
BEGIN { WILL snow with CGA... }
move( savescreen, biosvid^, sizeof(savescreen) );
END;
PROCEDURE SaveCursor; { save current cursor size and }
BEGIN { position }
Regs.AH := 3; { Get Cursor Position }
Regs.BH := 0;
Intr( $10, Regs );
oldpos := Regs.DX; { Save return values }
oldcur := Regs.CX;
{ known bug on some monochrome }
{ adapters reports the wrong }
{ cursor shape when both color }
{ and monochrome systems are }
{ installed. }
IF( (curmode = MONO) AND (oldcur = $0607) ) THEN
oldcur := $0c0d;
Regs.AH := 1;
Regs.CX := $ffff;
Intr( $10, Regs );
END;
PROCEDURE RestoreCursor; { restore saved cursor position }
BEGIN { and size }
Regs.AH := 2; { restore saved position }
Regs.BH := 0;
Regs.DX := oldpos;
Intr( $10, Regs );
Regs.AH := 1; { restore saved cursor type }
Regs.BH := 0;
Regs.CX := oldcur;
Intr( $10, Regs );
END;
{****************************< FixRows >******************************
* *
* Determine current video mode and set it up *
* ------------------------------------------ *
* *
* This function determines the current video mode at popup time, and *
* if it is one of the four text modes sets to 80 columns, the *
* default color scheme, and initializes the video RAM pointer. *
* Note that this program does NOT restore to 40-column mode after popping *
* up; that, like de-snowing the video, is left for you to program. *
* *
* Parameters: *
* None *
* *
* Returns: *
* None *
* *
*************************************************************************CR}
PROCEDURE fixrows; { Re-initialize current video }
BEGIN { information for new instance }
{ of video usage }
curmode := word( mem[$40:$49] ); { Get current mode at popup }
CASE (curmode) OF { deal with text modes }
BW40:
BEGIN
textmode(BW80); { we need 80 columns }
NormAtt := MONONORM; { use Monochrome Attributes }
RevAtt := MONOREV;
END;
BW80, MONO:
BEGIN
NormAtt := MONONORM; { use Monochrome Attributes }
RevAtt := MONOREV;
END;
C40:
BEGIN
textmode(C80); { we need 80 columns }
{ use Color attributes }
NormAtt := (YELLOW + (BLUE SHL 4)) ;
RevAtt := (WHITE + (RED SHL 4)) ;
END;
C80:
BEGIN { use Color attributes }
NormAtt := (YELLOW + (BLUE SHL 4)) ;
RevAtt := (WHITE + (RED SHL 4)) ;
END;
END;
IF(curmode = MONO) THEN { If monochrome .... }
biosvid := ptr($b000,124) { ... set pointer }
else { That means color .... }
biosvid := ptr($b800,124); { ... so set pointer }
END;
{****************************< SizeOfCode >******************************
* *
* Determine size of program to keep resident *
* ------------------------------------------ *
* *
* This function is an example of a function that can be used to determine *
* the size of the TSR that is to remain resident. For use with TP4, *
* no parameters are supplied and the value is like that for ALLHEAP *
* with MSC 5.0 or Turbo C 1.5; the stack is below the heap and the *
* entire heap and stack are counted in the value. *
* *
* Parameters: *
* None *
* *
* Returns: *
* Number of 16-byte paragraphs of memory to keep when going resident. *
* *
*************************************************************************CR}
FUNCTION SizeOfCode : word;
VAR
used : word;
BEGIN
used := Seg(HeapPtr^) - PrefixSeg; { these are built-ins for TP4.. }
SizeOfCode := used; { return number of paragraphs }
END;
{****************************< do_cpyrt >******************************
* *
* Display Copyright Information *
* ----------------------------- *
* *
* Function to display formatted copyright information on the screen. *
* *
* Parameters: *
* none *
* *
* Returns: *
* none *
* *
*************************************************************************CR}
PROCEDURE do_cpyrt;
BEGIN
ClrScr;
textattr := RevAtt;
c_str(2, ' TesSeRact Date/Time Demonstration Program ');
textattr := NormAtt;
c_str(4, 'Copyright 1986, 1987, 1988, TesSeRact Development Team');
c_str(5, 'All Rights Reserved');
END;
{****************************< DisplayTime >******************************
* *
* 'Poke' current time into video RAM *
* ---------------------------------- *
* *
* Converts the date and time values from binary to ASCII, then pokes *
* into rightmost 18 locations of the Video RAM segment for top row. *
* *
* Parameters: *
* none *
* *
* Returns: *
* none *
* *
*************************************************************************CR**}
PROCEDURE DisplayTime;
VAR
i: integer ;
j: integer ;
vidram : pointer;
BEGIN
vidram := biosvid;
yr := yr MOD 100;
buffer[0] := (mon DIV 10) + $30;
buffer[1] := (mon MOD 10) + $30;
buffer[2] := ORD('/');
buffer[3] := (day DIV 10) + $30;
buffer[4] := (day MOD 10) + $30;
buffer[5] := ORD('/');
buffer[6] := (yr DIV 10) + $30;
buffer[7] := (yr MOD 10) + $30;
buffer[8] := ORD(' ');
buffer[9] := ORD(' ');
buffer[10] := (hours DIV 10) + $30;
buffer[11] := (hours MOD 10) + $30;
buffer[12] := ORD(':');
buffer[13] := (mins DIV 10) + $30;
buffer[14] := (mins MOD 10) + $30;
buffer[15] := ORD(':');
buffer[16] := (secs DIV 10) + $30;
buffer[17] := (secs MOD 10) + $30;
FOR i := 0 TO 17 DO
BEGIN
j := word(vidram^) AND $FF00;
j := j OR buffer[i];
word(vidram^) := j;
vidram := pointer( longint( vidram ) + 2 );
END
END;
{****************************< AdjustTime >******************************
* *
* Call DOS to get the current time *
* -------------------------------- *
* *
* Calls DOS to get the current time into appropriate global values, *
* then adjusts the "ticks" value more accurately from the 1/100 sec *
* value returned by DOS. Repeats to get date similarly. *
* *
* Parameters: *
* none *
* *
* Returns: *
* none *
* *
*************************************************************************CR**}
PROCEDURE AdjustTime;
VAR
WkDy,
Sec100 : word;
BEGIN
gettime( hours, mins, secs, Sec100 );
ticks := longint(91 * (100 - Sec100)) div 500;
getdate( yr, mon, day, wkdy );
END;
{****************************< InitTsrDemo >******************************
* *
* Initialize variables and video *
* ------------------------------ *
* *
* This function just initializes everything, displays a sign-on message, *
* and gets the clock info for the first time. *
* *
* Parameters: *
* none *
* *
* Returns: *
* none *
* *
*************************************************************************CR**}
PROCEDURE InitTsrDemo;
BEGIN
curmode := LastMode AND $7F; { save current mode for later }
fixrows;
window(1,1,80,8);
textattr := NormAtt;
do_cpyrt;
c_str(7,' Press Alt-LeftShift-T to activate the TesSeRact Demonstration Program ');
AdjustTime;
DisplayTime;
END;
{*************************************************************
* TSR Procedures *
*********************************************************CR**}
{$F+} PROCEDURE TsrMain; {$F-}
VAR
oldstat, ret : word;
BEGIN
SaveCursor;
fixrows; { determine video mode }
CASE (curmode) OF
0..3, 7: { if in any text mode.... }
BEGIN
window(1,1,80,25);
getscrn; { save current screen first.. }
textattr := (NormAtt);
clrscr; { wipe it clean for the popup }
do_cpyrt;
oldstat := TsGetStat(idnum); { get the RM status word }
gotoxy(5,7);
write('This TSR is currently using the following procedures:');
IF(oldstat AND TSRUSEPOPUP)<>0 THEN
BEGIN
gotoxy(10,wherey+1);
write('User-Defined PopUp Procedure');
END;
IF(oldstat AND TSRUSEBACK)<>0 THEN
BEGIN
gotoxy(10,wherey+1);
write('User-Defined Background Procedure');
END;
IF(oldstat AND TSRUSETIMER)<>0 THEN
BEGIN
gotoxy(10,wherey+1);
write('User-Defined Timer Procedure');
END;
IF(oldstat AND TSRUSEUSER)<>0 THEN
BEGIN
gotoxy(10,wherey+1);
write('User-Defined User Communication Procedure');
END;
c_str(24,'Press "R" to remove TSR from memory; any other key to return');
repeat { wait for any keypress }
ret := ord(ReadKey);
until ret <> 0;
IF(char(ret AND $5F) = 'R') THEN
ret := TsRelease(idnum); { release if requested to do so }
putscrn; { put screen back as it was }
RestoreCursor;
END { of text mode popup }
ELSE { If in graphics mode .... }
TessBeep; { Beep and exit }
END; { of CASEs }
END;
{$F+} FUNCTION TsrBackCheck : word; {$F-}
BEGIN
TsrBackCheck := (BackFlag);
END;
{$F+} PROCEDURE TsrBackProc; {$F-}
BEGIN
AdjustTime; { call DOS to resynchronize the display }
DisplayTime;
BackFlag := 0;
END;
{$F+} PROCEDURE TsrTimerProc; {$F-}
{ This procedure comes up at each timer tick, and sets the flag to
request background processing once each second.
The background procedure does the actual screen display and corrects
the "ticks" counter to the proper value, depending on when it gains
control.
}
BEGIN
DEC ( ticks ); { bump the tick counter }
IF (ticks < 1) OR (ticks > 20) THEN { catch any outofrange }
BEGIN
ticks := 20;
BackFlag := 1; { ask background to upd }
END; { of second counted }
END;
{$F+} PROCEDURE TsrUserProc( UserPtr : pointer ); {$F-}
BEGIN
write('This is the user procedure: Passed ptr = ');
writeln( seg(UserPtr^), ':', ofs(UserPtr^), ' (decimal)' );
END;
{$F+} PROCEDURE TsrCleanUp ( RemoveTSR : Boolean ); {$F-}
{ This procedure, added in version 0.70, permits a TSR to "wipe its feet"
at release time, and MUST be used to perform the initialization code.
It is called twice by the TesSeRact routines: once, with RemoveTSR set
FALSE, from DoTsrInit, and again, with RemoveTSR set TRUE, from the
ReleaseTSR function. If a TSR has files open, it can close them. Here,
only a CRT message is produced.
}
BEGIN
IF (RemoveTSR) THEN
BEGIN
Writeln( 'TSR Demo has been removed from memory.' );
ErrorAddr := NIL; { ALL: !!!THIS!!! was the bug that killed us }
END
ELSE
BEGIN { install (setup) the TSR }
InitTsrDemo;
END
END;
{****************************< main >******************************
* *
* Simple-minded main. Calculates top of background stack region, *
* sets the stack points for the TSR; tests to see if we are already *
* resident; if so, displays ID number and exits. If it is OK *
* to install, calls InitTsrDemo, and then goes resident with *
* DoTsrInit(). *
* *
* Parameters: *
* none *
* *
* Returns: *
* none *
* *
*************************************************************************CR}
VAR
tsrname : string[8];
defptr,
stackptr : pointer; { Pointer to top of Background }
{ stack area }
BEGIN
DirectVideo := False; { force I/O to go through BIOS }
tsrname := 'TSDAYTIM';
TsSetAdrTP4( @TsrTimerProc, 0 ); { must set runtime addresses }
TsSetAdrTP4( @TsrBackProc, 1 ); { to our own procedures }
TsSetAdrTP4( @TsrMain, 2 );
TsSetAdrTP4( @TsrBackCheck, 3 );
TsSetAdrTP4( @TsrUserProc, 4 );
TsSetAdrTP4( @TsrCleanUp, 5 );
defptr := NIL; { necessary due to TP type checks }
stackptr := @BackStack[(sizeof(BackStack)-3)];
{ Calculate new stack pointer }
{ See TSINTVEC.PAS for split stks }
TsSetStack(defptr^, stackptr^); { Set Popup Stack to defptr and }
{ background stack to stackptr }
{ Are we already here? note [1].. }
IF(TsCheckResident( tsrname[1], idnum ) = $ffff) THEN
BEGIN { Yep! }
writeln('The TesSeRact Date/Time Demo TSR has already been loaded.');
writeln(' Use ALT-LeftShift-T to PopUp the TsrMain() routine.');
write (' Use ID Number ', idnum, ' to communicate through ');
writeln( 'TesSeRact Multiplex functions.');
halt(1);
END;
ClrScr;
IF( TsDoInit( { Try to go resident; no return }
TSRHOT_T,
TSRPOPALT + TSRPOPLSHIFT,
TSRUSEPOPUP + TSRUSEBACK + TSRUSETIMER + TSRUSEUSER,
SizeOfCode)<>0 ) THEN { returns only if attempt failed }
writeln('DoTsrInit function failed!');
END.